perm filename DFUNC.F4[PUR,LCS] blob sn#367597 filedate 1979-07-23 generic text, type T, neo UTF8
C  ********** DISPLAY OUTPUT **********
	SUBROUTINE DPY(F,IY)
	DIMENSION F(1)
	IF(IY)GO TO 3
C  IY IS TO SUPERIMPOSE WAVES FROM 'CRUNCH'
2	CALL DPYX(IY)
	CALL DPYBRT(5)
3	J=F(1)*256.0
	I=J+128
	CALL AIVECT(-255,I)
	DO 1017 K=2,512
	I=F(K)*256.0
	CALL RVECT(1,I-J)
1017	J=I
	CALL DPYOUT(1)
	END

	SUBROUTINE DPYX(IGRID)
C  ON DATADISK GRIDS MUST BE RESEST EACH TIME AROUND.
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	COMMON FUNC(512),F2(512),K,I
	COMMON/DY/IDPY(800),NUMS(5)
	DATA NUMS/'1','25','50','75','100'/
	CALL DDCLR
C75	CALL CLRPOG(1)
	IT=-180
	IB=-500
	CALL TYPLOC(IT,IB)
	CALL DPYSET(1,IDPY,800)
	CALL DPYBRT(2)
	IF(IGRID.NE.1)GO TO 2
	CALL ALINE(256,128,-258,128)
	CALL ALINE(-256,-128,-256,384)
10	CALL DPYBIG(6)
	CALL DPYTXT(-410,240,FNUM1,1)
	CALL DPYOUT(1)
	RETURN

C  DRAWS GRIDWORK
2	DO 501 K=384,-128,-128
501	CALL ALINE(256,K,-258,K)
	DO 502 K=-256,260,128
502	CALL ALINE(K,-130,K,384)
	N=-268
	CALL DPYBIG(3)
	CALL DPYTXT(-285,124,'0',1)
	DO 503 K=1,5
	CALL DPYTXT(N,388,NUMS(K),1)
503	N=N+128
C  NUMBERS OVER GRID
	GO TO 10
	END

	SUBROUTINE PLOTIT(FUNC,EY,P)
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	DIMENSION FUNC(1)
	IF(P.EQ.'P')GO TO 1
	IF(P.EQ.0)GO TO 4
	Y=1
	X=2.
	IF(P.NE.'X')GO TO 6
	X=1.5
	Y=.5
6	CALL PLOTS(K)
	P=0
	GO TO 40
1	TYPE 2
	CALL PLOTS(K)
	ACCEPT 3,X
	IF(X.EQ.0)X=SZX
	IF(X.EQ.0)X=1.
	SZX=X
40	SZ=X/5.12
	S=0
	J=1
	JK=X*3
	CALL SYMBOL(SZ,4.*SZ,JK,0,FLNM,5)
4	CALL SYMBOL(SZ,-3.*SZ,JK,0,B(2,JX),3)
	CALL PLOT(5.12*SZ,0.,3)
	CALL PLOT(0.,0.,2)
	CALL PLOT(0.,-2.*SZ,3)
	CALL PLOT(0.,2.*SZ,2)

72	CALL PLOT(.01*SZ,FUNC(1)*2.*SZ,3)
	DO 73 K=2,512
	R=K/100.0
73	CALL PLOT(R*SZ,FUNC(K)*2.*SZ,2)
	T=0
	Q=Y+5*SZ
	IF(J.NE.5)GO TO 5
	Q=-S
	T=-7*SZ
5	CALL PLOT(Q,T,-3)
	S=S+Q
	J=J+1

2	FORMAT(' TYPE SIZE - '$)
3	FORMAT(F)
	END

	SUBROUTINE TYPINP
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	COMMON FUNC(512),F2(512),K,I
	JT=4
	IF(XA(JX).EQ.'SEG')JT=2
	DO 1 K=1,178
	IF(AA(1,K,JX).EQ.999) RETURN
	TYPE 371,K,(AA(L,K,JX),L=1,JT)
C JX=FUNC ORDER NUM.  JT=2=SEG, =4=SYNTH    999=END OF SYNTH, ≥100=END OF SEG.
1	IF(AA(2,K,JX).GE.100)RETURN
371	FORMAT(I3,') ',4F8.2)
	END